home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Database How-To / Visual Basic 4 Database - How-to (The Waite Group)(1995).iso / newgrp32.fr_ / newgrp32.fr
Text File  |  1995-09-04  |  4KB  |  152 lines
  1. VERSION 4.00
  2. Begin VB.Form Form1 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "Create Group"
  5.    ClientHeight    =   2100
  6.    ClientLeft      =   1080
  7.    ClientTop       =   1530
  8.    ClientWidth     =   4980
  9.    BeginProperty Font 
  10.       name            =   "MS Sans Serif"
  11.       charset         =   0
  12.       weight          =   700
  13.       size            =   8.25
  14.       underline       =   0   'False
  15.       italic          =   0   'False
  16.       strikethrough   =   0   'False
  17.    EndProperty
  18.    Height          =   2505
  19.    Left            =   1020
  20.    LinkTopic       =   "Form1"
  21.    ScaleHeight     =   2100
  22.    ScaleWidth      =   4980
  23.    Top             =   1185
  24.    Width           =   5100
  25.    Begin VB.TextBox txtGroupName 
  26.       Height          =   315
  27.       Left            =   2160
  28.       TabIndex        =   3
  29.       Top             =   360
  30.       Width           =   2115
  31.    End
  32.    Begin VB.CommandButton cmdClose 
  33.       Cancel          =   -1  'True
  34.       Caption         =   "Cl&ose"
  35.       Height          =   555
  36.       Left            =   2520
  37.       TabIndex        =   2
  38.       Top             =   1080
  39.       Width           =   1755
  40.    End
  41.    Begin VB.CommandButton cmdCreateGroup 
  42.       Caption         =   "&Create Group"
  43.       Default         =   -1  'True
  44.       Height          =   555
  45.       Left            =   480
  46.       TabIndex        =   1
  47.       Top             =   1080
  48.       Width           =   1755
  49.    End
  50.    Begin VB.Label Label1 
  51.       Alignment       =   1  'Right Justify
  52.       AutoSize        =   -1  'True
  53.       BackColor       =   &H00C0C0C0&
  54.       Caption         =   "&Group name:"
  55.       Height          =   195
  56.       Left            =   780
  57.       TabIndex        =   0
  58.       Top             =   420
  59.       Width           =   1095
  60.    End
  61. End
  62. Attribute VB_Name = "Form1"
  63. Attribute VB_Creatable = False
  64. Attribute VB_Exposed = False
  65. Option Explicit
  66.  
  67. Private Declare Function GetPrivateProfileString _
  68.     Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpSectionName As String, _
  69.     ByVal lpKeyName As Any, ByVal lpDefault As String, _
  70.     ByVal lpReturnedString As String, ByVal Size As Integer, _
  71.     ByVal lpFileName As String) As Integer
  72.  
  73.  
  74. Private Sub Form_Load()
  75.     Dim myUser As String, myPass As String
  76.     Dim winDir As String * 128
  77.     Dim dirLen As Integer
  78.     
  79.     On Error GoTo LoadError
  80.     
  81.     ' Set the user and passwords for initial login.
  82.     myUser = "Admin"
  83.     myPass = "theboss"
  84.     
  85.     ' read VBDBHT.INI to get the name of the system database,
  86.     ' then assign that name to the SystemDB property
  87.     DBEngine.SystemDB = GetSystemDatabase()
  88.  
  89.     ' log in
  90.     DBEngine.DefaultUser = myUser
  91.     DBEngine.DefaultPassword = myPass
  92.  
  93. Exit Sub
  94. LoadError:
  95.     MsgBox Err & " " & Error$
  96. End
  97.  
  98. End Sub
  99.  
  100. Private Sub cmdCreateGroup_Click()
  101.     Dim newGroup As Group
  102.     Dim thePID As String
  103.     
  104.     On Error GoTo ChangeError
  105.     
  106.     If txtGroupName = "" Then Error 32765
  107.     thePID = txtGroupName
  108.     If Len(thePID) > 20 Then
  109.         thePID = Left$(thePID, 20)
  110.     Else
  111.         Do While Len(thePID) < 4
  112.             thePID = thePID & "_"
  113.         Loop
  114.     End If
  115.     Set newGroup = DBEngine.Workspaces(0).CreateGroup(txtGroupName, thePID)
  116.     DBEngine.Workspaces(0).Groups.Append newGroup
  117.     MsgBox "Group " & txtGroupName & " created", vbInformation
  118.     txtGroupName = ""
  119. Exit Sub
  120. ChangeError:
  121.     Dim msg As String
  122.     Select Case Err.Number
  123.         Case 3390
  124.             msg = "There is already a group named " & txtGroupName
  125.         Case 32765
  126.             msg = "You have not entered a group name"
  127.         Case Else
  128.             msg = Err.Description
  129.     End Select
  130.     MsgBox msg, vbExclamation
  131. End Sub
  132.  
  133. Private Sub cmdClose_Click()
  134.     End
  135. End Sub
  136.  
  137. Private Function GetSystemDatabase() As String
  138.     ' Returns the name of the system directory
  139.     
  140.     Const INI_FILENAME = "VBDBHT.INI"
  141.     Const MAX_PATH = 128
  142.  
  143.     Dim lpReturnedString As String * MAX_PATH
  144.     Dim bytesBack As Integer
  145.     
  146.     bytesBack = GetPrivateProfileString("Options", _
  147.         "SystemDB", "", lpReturnedString, MAX_PATH, INI_FILENAME)
  148.     GetSystemDatabase = IIf(bytesBack > 0, Left$(lpReturnedString, bytesBack), "")
  149.     
  150. End Function
  151.  
  152.